home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / simpfy_let.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  14.9 KB  |  381 lines
  1. (herald (front_end simplify_let)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Simplifying LET nodes, i.e. any call with a lambda node as the procedure.
  28. ;;; Many of these not created by the LET macro itself.
  29.  
  30. ;;; This is the first pass at simplifying a LET node.
  31. ;;;  (CALL-PROC CALL) == PROC which is a lambda node.  This does as many
  32. ;;; substitutions as possible without simplifying the body of PROC.  If any
  33. ;;; arguments remain unsubstituted then REALLY-SIMPLIFY-LET is called.
  34. ;;;
  35. ;;; Compiling STRING.T this removed 192 out of 350 LET nodes (that reached
  36. ;;; the ELSE clause) without resorting to REALLY-SIMPLIFY-LET.  Compiling 
  37. ;;; EVAL.T 775 out of 1253 LET nodes were removed.
  38.  
  39. (define (simplify-let proc call)
  40.   (cond ((not (arg-check-of-lambda proc call))
  41.          (walkcdr simplify (call-args call)) ; Just looking for more errors
  42.          (simplify-call proc)
  43.          (fix-call-to-lambda call proc)
  44.          t)
  45.         ((and (null? (lambda-variables proc))
  46.               (null? (lambda-rest-var proc)))
  47.          (replace call (detach (lambda-body proc)))
  48.          t)
  49.         (else
  50.          (set (node-simplified? call) t)
  51.          (remove-unused-arguments proc call)
  52.          (walkcdr simplify (call-args call))
  53.          (quick-substitute-arguments proc call)
  54.          (if (remove-unused-let call proc)
  55.              t
  56.              (really-simplify-let proc call)))))
  57.  
  58. ;;; Simplify the body of PROC and then try substituting the arguments again.
  59. ;;; If all the arguments can be substituted the call node is removed.
  60. ;;; CHANGE? indicates that the let node has been moved in the tree and thus
  61. ;;; its parent must resimplify.
  62. ;;;
  63. ;;; SUBSTITUTE-JOIN-ARGUMENTS copies arguments in an attempt to remove
  64. ;;; conditionals via constant folding.
  65.  
  66. (define (really-simplify-let proc call)
  67.   (iterate loop ((change? nil))
  68.     (set (node-simplified? proc) t)
  69.     (simplify-call proc)
  70.     (substitute-arguments proc call)
  71.     (cond ((substitute-join-arguments proc call)
  72.            (loop t))
  73.           ((not (node-simplified? proc))
  74.            (loop change?))
  75.           (else
  76.            (remove-unused-arguments proc call)
  77.            (cond ((or (remove-unused-let call proc)
  78.                       change?)
  79.                   (set (node-simplified? call) nil)
  80.                   t)
  81.                  (else
  82.                   (set (node-simplified? call) t)
  83.                   nil))))))
  84.  
  85. ;;; Replace CALL by the body of its procedure PROC if CALL has no arguments.
  86.  
  87. (define (remove-unused-let call proc)
  88.   (cond ((null? (call-args call))
  89.          (if (lambda-rest-var proc)
  90.              (walk-refs-safely (lambda (ref)
  91.                                  (replace ref (create-literal-node '())))
  92.                                (lambda-rest-var proc)))
  93.          (replace call (detach (lambda-body proc)))
  94.          t)
  95.         (else
  96.          nil)))
  97.  
  98. ;;; Removed unused arguments to a lambda-node in call position.  Destructively
  99. ;;; changes the lists of arguments and variables.  If the lambda-node is
  100. ;;; n-ary an explicit call to LIST is added to cons up the list of arguments.
  101.  
  102. (define (remove-unused-arguments node call)
  103.   (if (and (lambda-rest-var node)
  104.            (not (used? (lambda-rest-var node))))
  105.       (set (cadr (lambda-all-variables node)) nil))
  106.   (iterate loop ((vars (lambda-rest+variables node))
  107.                  (args (call-proc+args call))
  108.                  (exits (call-exits call))
  109.                  (n 2))
  110.     (cond ((null? (cdr vars))
  111.            (remove-let-rest-var node call args))
  112.           ((used? (cadr vars))
  113.            (set (variable-number (cadr vars)) n)
  114.            (set (node-role (cadr args)) (call-arg (fx- n 1)))
  115.            (loop (cdr vars) (cdr args) (fx- exits 1) (fx+ n 1)))
  116.           (else
  117.            (set (cdr vars) (cddr vars)) ; Evil
  118.            (erase-all (cadr args))
  119.            (set (cdr args) (cddr args)) ; Extremely Evil
  120.            (if (fx< 0 exits)
  121.                (set (call-exits call)
  122.                     (fx- (call-exits call) 1)))
  123.            (loop vars args (fx- exits 1) n)))))
  124.  
  125. ;;; Just like REMOVE-UNUSED-ARGUMENTS except that it substitutes arguments
  126. ;;; for variables instead of removing them.
  127.  
  128. (define (quick-substitute-arguments node call)
  129.   (iterate loop ((vars (lambda-rest+variables node))
  130.                  (args (call-proc+args call))
  131.                  (exits (call-exits call))
  132.                  (n 2))
  133.     (cond ((null? (cdr vars))
  134.            nil)
  135.           ((quick-substitute (cadr vars) (cadr args) n)
  136.            (set (cdr vars) (cddr vars)) ; Evil
  137.            (set (cdr args) (cddr args)) ; Extremely Evil
  138.            (if (fx< 0 exits)
  139.                (set (call-exits call)
  140.                     (fx- (call-exits call) 1)))
  141.            (loop vars args (fx- exits 1) n))
  142.           (else
  143.            (loop (cdr vars) (cdr args) (fx- exits 1) (fx+ n 1))))))
  144.  
  145. (define (quick-substitute var val n)
  146.   (set (variable-number var) n)
  147.   (set (node-role val) (call-arg (fx- n 1)))
  148.   (cond ((substitute? var val)
  149.          (substitute var val t)
  150.          t)
  151.         (else nil)))
  152.  
  153. ;;; Substitute VAL for VAR if VAL is a literal-node, a primop-node, or
  154. ;;; a reference to a lexically bound or DEFINEd variable.
  155.  
  156. (define (substitute? var val)
  157.   (ignore var)
  158.   (or (and (reference-node? val)
  159.            (let ((var (reference-variable val)))
  160.              (or (variable-binder var)
  161.                  (let ((def (get-variable-definition var)))
  162.                    (and def 
  163.                         (or (eq? 'constant (definition-variant def))
  164.                             (eq? 'define (definition-variant def))))))))
  165.       (literal-node? val)
  166.       (primop-node? val)))
  167.  
  168. ;;; Try to substitute any arguments to LAMBDA-PROC that are lambda nodes.
  169. ;;; Three different methods are tried.  SUBSTITUTE-LAMBDA? checks that there
  170. ;;; is only one reference to the variable and the reference is in call or
  171. ;;; exit position or only one call down in the tree.  
  172. ;;; PARTIAL-SUBSTITUTE-VARIABLE? and PARTIAL-SUBSTITUTE-LAMBDA? determine
  173. ;;; whether it is worth duplicating the argument to do the substitution.
  174.  
  175. (define (substitute-arguments lambda-proc call-node)
  176.   (walk (lambda (var val)
  177.           (cond ((not (used? var)) nil)  ; VAL may be *EMPTY* if VAR is unused
  178.                 ((reference-node? val)
  179.                  (partial-substitute-variable var (reference-variable val)))
  180.                 ((not (lambda-node? val))
  181.                  nil)
  182.                 ((substitute-lambda? var)
  183.                  (substitute var val t))
  184.                 ((partial-substitute-lambda? val)
  185.                  (partial-substitute var val))
  186.                 (else
  187.                  (substitute-known-args var val))))
  188.         (lambda-variables lambda-proc)
  189.         (call-args call-node)))
  190.  
  191. (define (substitute-known-args var val)
  192.   (cond ((and (variable? (lambda-rest-var val))
  193.               (null? (variable-refs (lambda-rest-var val))))
  194.          (let ((len (length (lambda-variables val))))
  195.            (walk-refs-safely (lambda (n)
  196.                                (if (eq? call-proc (node-role n))
  197.                                    (shorten-call-args (node-parent n) len)))
  198.                              var)))))
  199.  
  200. (define (shorten-call-args call count)
  201.   (if (fx> (length (call-args call)) count)
  202.       (let ((rest (nthcdr (call-proc+args call) count)))
  203.         (walk erase-all (cdr rest))
  204.         (set (cdr rest) '()))))
  205.  
  206. ;;; Two versions of this.  We cannot use the strong one until the compiler
  207. ;;; can hoist lambdas back up again.
  208.  
  209. (define (strong-substitute-lambda? var)
  210.   (null? (cdr (variable-refs var))))
  211.  
  212. (define (weak-substitute-lambda? var)
  213.   (and (null? (cdr (variable-refs var)))
  214.        (let ((ref (car (variable-refs var))))
  215.          (or (eq? (node-role ref) call-proc)
  216.              (eq? (node-role ref) object-proc)
  217.              (call-exit? ref)
  218.              (eq? (variable-binder var) (node-parent (node-parent ref)))))))
  219.  
  220. (define substitute-lambda? weak-substitute-lambda?)
  221.  
  222. ;;; Substitute a lambda-node where it is called.
  223.  
  224. (define (partial-substitute-variable var val)
  225.   (let ((call (lambda-body (variable-binder var))))
  226.     (walk-refs-safely (lambda (ref)
  227.                         (if (eq? call (node-parent ref))
  228.                             (replace ref (create-reference-node val))))
  229.                       var)))
  230.  
  231. ;;; VAL is simple enough to be substituted in more than one location if
  232. ;;; it is not n-ary, its call is all leaf-nodes, and its procedure is not
  233. ;;; a reference to an integrable value.
  234.  
  235. (define (partial-substitute-lambda? val)
  236.   (and (or (not (lambda-rest-var val)) 
  237.            (null? (variable-refs (lambda-rest-var val))))
  238.        (every? (lambda (n)
  239.                  (leaf-node? n))
  240.                (call-proc+args (lambda-body val)))
  241.        (primop-node? (call-proc (lambda-body val)))))
  242.  
  243. ;;; Substitute VAL (a lambda-node) for VAR everywhere that it can be
  244. ;;; integrated.  References in non-call position need to be consed anyway
  245. ;;; so there is no reason not to substitute them as well (?).
  246.  
  247. (define (partial-substitute var val)  
  248.   (cond ((any? (lambda (ref)
  249.                  (or (eq? (node-role ref) call-proc)
  250.                      (call-exit? ref)))
  251.                (variable-refs var))
  252.          (substitute var val t))))
  253.  
  254. ;;; Removing rest vars from lambdas in call position
  255. ;;;
  256. ;;; ((LAMBDA (<vars> . X) <body>)
  257. ;;;  <vals> RV1 RV2 ... RVN)
  258. ;;;
  259. ;;; => ((LAMBDA (<vars>) <body>[X/'()]) <vals>) if N = 0
  260. ;;;
  261. ;;; => ((LAMBDA (<vars>)
  262. ;;;       (LIST (LAMBDA (X) <body>) RV1 RV2 ... RVN))
  263. ;;;     <vals>)       
  264.  
  265. (define (remove-let-rest-var proc call args)
  266.   (ignore call)
  267.   (let ((var (lambda-rest-var proc)))
  268.     (set (cadr (lambda-all-variables proc)) nil)
  269.     (cond ((and (not var)
  270.                 (null? (cdr args)))
  271.            (return))
  272.           ((not (used? var))
  273.            (walk erase-all (cdr args))
  274.            (set (cdr args) '()))    ; Extremely Evil
  275.           ((null? (cdr args))
  276.            (let ((val (create-literal-node '()))) 
  277.              (substitute var val nil)
  278.              (erase val)))
  279.           (else
  280.            (let ((vals (map detach (cdr args)))
  281.                  (l-proc (get-system-variable '%list))
  282.                  (body (detach (lambda-body proc))))
  283.              (set (cdr args) '())
  284.              (let-nodes ((c1 ((* l-proc) 1 (^ l1) . vals))
  285.                           (l1 (#f (v var)) body))
  286.                (relate lambda-body proc c1)))))))
  287.  
  288. ;;;                 Simplifying Joins
  289. ;;;============================================================================
  290.  
  291. ;;; This looks for arguments in a let-node that test one of their arguments
  292. ;;; and get called with a known value:
  293. ;;;
  294. ;;;   (LET ((J (LAMBDA (... X ...)
  295. ;;;              ... (IF X ...) ...)))
  296. ;;;     ... (J ... <known value> ...) ...)
  297. ;;;
  298. ;;; If one is found, PARAMETERIZE is called to reduce the procedure to one
  299. ;;; that is cheap to copy:
  300. ;;; 
  301. ;;;   (LET ((...))                    ; parts of the original procedure
  302. ;;;     (LET ((J (LAMBDA (... X ...)
  303. ;;;                (IF X ...))))      ; all that's left
  304. ;;;       ... (J ... <known value> ...) ...)
  305. ;;;
  306. ;;; If PARAMETERIZE works, the new procedure is substituted for the variable.
  307.  
  308. ;;; Call JOIN-SUBSTITUTE on all variable/value pairs.
  309.  
  310. (define (substitute-join-arguments lambda-proc call)
  311.   (iterate loop ((vars (lambda-variables lambda-proc))
  312.                  (vals (call-args call))
  313.                  (change? nil))
  314.     (cond ((null? vars) change?)
  315.           ((and (used? (car vars)) ; (CAR VALS) may be *EMPTY* if VAR is unused
  316.                 (lambda-node? (car vals))  
  317.                 (join-substitute (car vars) (car vals)))
  318.            (loop (cdr vars) (cdr vals) t))
  319.           (else
  320.            (loop (cdr vars) (cdr vals) change?)))))
  321.  
  322. ;;; Get any calls that test arguments in VAL, and then find any calls to VAL
  323. ;;; that pass literal nodes to any of those arguments.  If there are any,
  324. ;;; try to parameterize VAL and substitute it for VAR.
  325.  
  326. ;;; This code only tries one simple cond call per variable and only one
  327. ;;; variable/literal pair per call to VAR. Bug.
  328.  
  329. (define (join-substitute var val)
  330.   (let ((calls (map get-simple-cond-call (lambda-variables val))))
  331.     (iterate loop ((refs (variable-refs var)))
  332.       (cond ((null? refs) nil)
  333.             ((and (eq? call-proc (node-role (car refs)))
  334.                   (call-and-literal-match calls
  335.                                           (call-args (node-parent (car refs)))))
  336.              => (lambda (call)
  337.                   (cond ((parameterize val call)
  338.                          (walk-refs-safely
  339.                           (lambda (ref) 
  340.                             (if (eq? call-proc (node-role ref))
  341.                                 (replace ref (copy-node-tree val))))
  342.                           var)
  343.                          t)
  344.                         (else
  345.                          (loop (cdr refs))))))
  346.              (else (loop (cdr refs)))))))
  347.  
  348. ;;; Find a matching non-false call and literal node argument.
  349.  
  350. (define (call-and-literal-match calls args)
  351.   (do ((calls calls (cdr calls))
  352.        (args args (cdr args)))
  353.       ((or (null? args)
  354.            (and (car calls)
  355.                 (literal-node? (car args))))
  356.        (if (null? calls) nil (car calls)))))
  357.  
  358. ;;; Find any call of the form (IF var ...)
  359.  
  360. (define (get-simple-cond-call var)
  361.   (and (variable? var)
  362.        (any simple-cond-ref (variable-refs var))))
  363.  
  364. (define (simple-cond-ref ref)
  365.   (let ((call (node-parent ref)))
  366.     (cond ((or (not (call-node? call))
  367.                (not (fx= 2 (call-exits call))))
  368.            nil)
  369.           (else
  370.            (destructure (((cond? #f #f test? true? t-ref) 
  371.                           (call-proc+args call)))
  372.              (if (and (primop-ref? cond? primop/conditional)
  373.                       (primop-ref? test? primop/test)
  374.                       (primop-ref? true? primop/true?)
  375.                       (eq? ref t-ref))
  376.                  call
  377.                  nil))))))
  378.  
  379.  
  380.  
  381.